The Atari Compendium/The Atari Compendium (Toad Computers) (1994).iso/files/prgtools/editors/emcs1857/1857sr~1.zoo/src/sorttab.c

C/C++ Source or Header | 1992-02-02 | 9.9 KB | 364 lines

/* GNU Emacs routines to deal with sort tables.
   Copyright (C) 1987 Free Software Foundation, Inc.

This file is part of GNU Emacs.

GNU Emacs is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY.  No author or distributor
accepts responsibility to anyone for the consequences of using it
or for whether it serves any particular purpose or works at all,
unless he says so in writing.  Refer to the GNU Emacs General Public
License for full details.

Everyone is granted permission to copy, modify and redistribute
GNU Emacs, but only under the conditions described in the
GNU Emacs General Public License.   A copy of this license is
supposed to have been given to you along with GNU Emacs so you
can know your rights and responsibilities.  It should be in a
file named COPYING.  Among other things, the copyright notice
and this notice must be preserved on all copies.  */

/* Written by Howard Gayle.  See chartab.c for details. */

#include "config.h"
#include "lisp.h"
#include "buffer.h"
#include "etctab.h"
#include "sorttab.h"

Lisp_Object Qsort_table_p;
DEFUN ("sort-table-p", Fsort_table_p, Ssort_table_p, 1, 1, 0,
   "Return t iff ARG is a sort table.")
(obj)
Lisp_Object obj;
{
return ((XTYPE (obj) == Lisp_Sorttab) ? Qt : Qnil);
}

static Lisp_Object
check_sort_table (obj)
Lisp_Object obj;
{
register Lisp_Object tem;

while (tem = Fsort_table_p (obj), NULL (tem))
   obj = wrong_type_argument (Qsort_table_p, obj, 0);
return (obj);
}

/* Convert the given Lisp_Sorttab to a Lisp_Object. */
static Lisp_Object
enlisp_sort_table (sp)
register struct Lisp_Sorttab *sp;
{
register Lisp_Object z; /* Return. */

if (sp == NULL_SORT_TABLE)
   z = Qnil;
else
   XSET (z, Lisp_Sorttab, sp);
return (z);
}

DEFUN ("case-distinct-table",
   Fcase_distinct_table, Scase_distinct_table, 0, 0, 0,
   "Return the case-distinct sort table of the current buffer.")
()
{
return (enlisp_sort_table (current_buffer->case_distinct_table_v));
}

DEFUN ("case-fold-table", Fcase_fold_table, Scase_fold_table, 0, 0, 0,
   "Return the case-fold sort table of the current buffer.")
()
{
return (enlisp_sort_table (current_buffer->case_fold_table_v));
}

DEFUN ("standard-case-distinct-table",
   Fstandard_case_distinct_table, Sstandard_case_distinct_table, 0, 0, 0,
   "Return the standard case-distinct sort table.\n\
This is the one used for new buffers.")
()
{
return (enlisp_sort_table (buffer_defaults.case_distinct_table_v));
}

DEFUN ("standard-case-fold-table",
   Fstandard_case_fold_table, Sstandard_case_fold_table, 0, 0, 0,
   "Return the standard case-fold sort table.\n\
This is the one used for new buffers.")
()
{
return (enlisp_sort_table (buffer_defaults.case_fold_table_v));
}

/* Store a case-distinct sort table.  Check for errors. */
static Lisp_Object
set_case_distinct_table (p, t)
struct Lisp_Sorttab **p; /* Points to where to store the sort table. */
register Lisp_Object t;  /* The sort table as a Lisp object. */
{
if (NULL (t))
   *p = NULL_SORT_TABLE;
else
   {
   t = check_sort_table (t);
   *p = XSORTTAB (t);
   }
return (t);
}

/* Store a case-fold sort table.  Check for errors. */
static Lisp_Object
set_case_fold_table (p, t)
struct Lisp_Sorttab **p; /* Points to where to store the sort table. */
register Lisp_Object t;  /* The sort table as a Lisp object. */
{
t = check_sort_table (t);
*p = XSORTTAB (t);
return (t);
}

DEFUN ("set-case-distinct-table",
   Fset_case_distinct_table, Sset_case_distinct_table, 1, 1, 0,
   "Select a new case-distinct sort table for the current buffer.\n\
One argument, a sort table.")
(table)
Lisp_Object table;
{
return (set_case_distinct_table (¤t_buffer->case_distinct_table_v, table));
}

DEFUN ("set-case-fold-table",
   Fset_case_fold_table, Sset_case_fold_table, 1, 1, 0,
   "Select a new case-fold sort table for the current buffer.\n\
One argument, a sort table.")
(table)
Lisp_Object table;
{
return (set_case_fold_table (¤t_buffer->case_fold_table_v, table));
}

DEFUN ("set-standard-case-distinct-table", Fset_standard_case_distinct_table,
   Sset_standard_case_distinct_table, 1, 1, 0,
   "Select a new standard case-distinct sort table.\n\
This does not change the sort tables of any existing buffers.\n\
One argument, a sort table.")
(table)
Lisp_Object table;
{
return (set_case_distinct_table (&buffer_defaults.case_distinct_table_v, table));
}

DEFUN ("set-standard-case-fold-table", Fset_standard_case_fold_table,
   Sset_standard_case_fold_table, 1, 1, 0,
   "Select a new standard case-fold sort table.\n\
This does not change the sort tables of any existing buffers.\n\
One argument, a sort table.")
(table)
Lisp_Object table;
{
return (set_case_fold_table (&buffer_defaults.case_fold_table_v, table));
}

/* Return the sort table for the current buffer. */
struct Lisp_Sorttab *
current_sort_table ()
{
register struct buffer *bp = current_buffer;

return ((NULL (bp->case_fold_search))
    ? bp->case_distinct_table_v
    : bp->case_fold_table_v);
}

/* Return the equivalence class table of the current sort table. */
char_t *
current_equiv_class_table ()
{
register struct Lisp_Sorttab *sp = current_sort_table ();

return ((sp == NULL_SORT_TABLE) ? ((char_t *) 0) : sp->srt_ec);
}

DEFUN ("make-sort-table", Fmake_sort_table, Smake_sort_table, 1, 1, 0,
   "Return a new sort table.  Argument is a list of elements in\n\
increasing order.  Each element is a list representing an\n\
equivalence class.")
(lst)
Lisp_Object lst;
{
register int                      i;
register struct Lisp_Sorttab *nt; /* New sort table. */
register Lisp_Object p; /* Steps through lst. */
register Lisp_Object ce; /* Current sublist. */
register char_t c; /* Current char in sublist. */
register char_t cec = 0; /* Current equivalence class. */
register Lisp_Object z; /* Return. */
char_t cvr[256]; /* Flag set if char covered. */

CHECK_CONS (lst, 1);
z = make_etc_table (sizeof (struct Lisp_Sorttab), Lisp_Sorttab);
nt = XSORTTAB (z);
for (i = 0; i <= 255; ++i)
   cvr[i] = 0;
i = 0;
for (p = lst; !NULL (p); p = Fcdr (p))
   {
   ce = Fcar (p);
   CHECK_CONS (ce, 2);
   nt->srt_dope[cec].ec_lo = (char_t) i;
   for (; !NULL (ce); ce = Fcdr (ce))
      {
      c = get_char_arg (Fcar (ce));
      if (cvr[c]) arg_out_of_range (lst);
      nt->srt_ec[c] = cec;
      nt->srt_chars[i++] = c;
      ++cvr[c];
      }
   nt->srt_dope[cec++].ec_hi = (char_t) (i - 1);
   }
for (i = 0; i <= 255; ++i)
   if (!cvr[i]) arg_out_of_range (lst);
return (z);
}

DEFUN ("get-sort-table-ec",
   Fget_sort_table_ec, Sget_sort_table_ec, 2, 2, 0,
   "Return the equivalence class containing character CHAR in\n\
sort table TABLE.  The equivalence class is represented as a string.")
(ch, table)
Lisp_Object ch;
register Lisp_Object table;
{
register struct Lisp_Sorttab *sp; /* Sort table. */
register int ec;                     /* Equivalence class number. */
register int l;                         /* Index of first char in EC. */

table = check_sort_table (table);
sp = XSORTTAB (table);
ec = sp->srt_ec[get_char_arg (ch)];
l = sp->srt_dope[ec].ec_lo;
return (make_string (&sp->srt_chars[l], sp->srt_dope[ec].ec_hi - l + 1));
}

DEFUN ("get-sort-table-ec-num",
   Fget_sort_table_ec_num, Sget_sort_table_ec_num, 2, 2, 0,
   "Return the equivalence class number of character CHAR in\n\
sort table TABLE.")
(ch, table)
Lisp_Object ch;
register Lisp_Object table;
{
register Lisp_Object z;

table = check_sort_table (table);
XFASTINT (z) = XSORTTAB (table)->srt_ec[get_char_arg (ch)];
return (z);
}

DEFUN ("string-lessp*", Fstring_lesspX, Sstring_lesspX, 2, 3, 0,
   "T iff string S1 is less than string S2, according to sort\n\
table TABLE (default current sort table).")
(s1, s2, table)
Lisp_Object s1, s2;
Lisp_Object table;
{
register int i;
register char_t *p1, *p2;
register int end;
register char_t *tt; /* Equivalence class table. */
register char_t t1, t2; /* Translated characters. */
Lisp_Object Fstring_lessp ();

if (NULL (table))
   {
   tt = current_equiv_class_table ();
   if (tt == ((char_t *) 0)) return (Fstring_lessp (s1, s2));
   }
else
   {
   table = check_sort_table (table);
   tt = XSORTTAB (table)->srt_ec;
   }
CHECK_STRING (s1, 0);
CHECK_STRING (s2, 1);
p1 = XSTRING (s1)->data;
p2 = XSTRING (s2)->data;
end = XSTRING (s1)->size;
if (end > XSTRING (s2)->size) end = XSTRING (s2)->size;
for (i = 0; i < end; i++)
   {
   t1 = tt[p1[i]];
   t2 = tt[p2[i]];
   if (t1 != t2) return ((t1 < t2) ? Qt : Qnil);
   }
return ((i < XSTRING (s2)->size) ? Qt : Qnil);
}

init_sort_table_once ()
{
register struct Lisp_Sorttab *sp;
register int c; /* Current char. */
register int i = 0;
register Lisp_Object z;
register int cec = 0; /* Current equivalence class. */

Fset_standard_case_distinct_table (Qnil);

z = make_etc_table (sizeof (struct Lisp_Sorttab), Lisp_Sorttab);
sp = XSORTTAB (z);
for (c = 0; c < 'A'; ++c)
   {
   sp->srt_ec[c] = cec;
   sp->srt_dope[cec].ec_lo = (char_t) i;
   sp->srt_dope[cec++].ec_hi = (char_t) i;
   sp->srt_chars[i++] = c;
   }
for (; c <= 'Z'; ++c)
   {
   sp->srt_ec[c] = cec;
   sp->srt_ec[c - 'A' + 'a'] = cec;
   sp->srt_dope[cec].ec_lo = (char_t) i;
   sp->srt_chars[i++] = c;
   sp->srt_dope[cec++].ec_hi = (char_t) i;
   sp->srt_chars[i++] = c - 'A' + 'a';
   }
for (; c < 'a'; ++c)
   {
   sp->srt_ec[c] = cec;
   sp->srt_dope[cec].ec_lo = (char_t) i;
   sp->srt_dope[cec++].ec_hi = (char_t) i;
   sp->srt_chars[i++] = c;
   }
for (c = '{'; c <= 255; ++c)
   {
   sp->srt_ec[c] = cec;
   sp->srt_dope[cec].ec_lo = (char_t) i;
   sp->srt_dope[cec++].ec_hi = (char_t) i;
   sp->srt_chars[i++] = c;
   }
Fset_standard_case_fold_table (z);
}

syms_of_sort_table ()
{
Qsort_table_p = intern ("sort-table-p");
staticpro (&Qsort_table_p);

defsubr (&Ssort_table_p);
defsubr (&Scase_distinct_table);
defsubr (&Scase_fold_table);
defsubr (&Sstandard_case_distinct_table);
defsubr (&Sstandard_case_fold_table);
defsubr (&Sset_case_distinct_table);
defsubr (&Sset_case_fold_table);
defsubr (&Sset_standard_case_distinct_table);
defsubr (&Sset_standard_case_fold_table);
defsubr (&Smake_sort_table);
defsubr (&Sget_sort_table_ec);
defsubr (&Sget_sort_table_ec_num);
defsubr (&Sstring_lesspX);
}